home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / low.lsp < prev    next >
Encoding:
Text File  |  1992-09-09  |  32.0 KB  |  738 lines

  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;; This file contains portable versions of low-level functions and macros
  28. ;;; which are ripe for implementation specific customization.  None of the
  29. ;;; code in this file *has* to be customized for a particular Common Lisp
  30. ;;; implementation. Moreover, in some implementations it may not make any
  31. ;;; sense to customize some of this code.
  32. ;;;
  33. ;;; But, experience suggests that MOST Common Lisp implementors will want
  34. ;;; to customize some of the code in this file to make PCL run better in
  35. ;;; their implementation.  The code in this file has been separated and
  36. ;;; heavily commented to make that easier.
  37. ;;;
  38. ;;; Implementation-specific version of this file already exist for:
  39. ;;; 
  40. ;;;    Symbolics Genera family     genera-low.lisp
  41. ;;;    Lucid Lisp                  lucid-low.lisp
  42. ;;;    Xerox 1100 family           xerox-low.lisp
  43. ;;;    ExCL (Franz)                excl-low.lisp
  44. ;;;    Kyoto Common Lisp           kcl-low.lisp
  45. ;;;    Vaxlisp                     vaxl-low.lisp
  46. ;;;    CMU Lisp                    cmu-low.lisp
  47. ;;;    H.P. Common Lisp            hp-low.lisp
  48. ;;;    Golden Common Lisp          gold-low.lisp
  49. ;;;    Ti Explorer                 ti-low.lisp
  50. ;;;    
  51. ;;;
  52. ;;; These implementation-specific files are loaded after this file.  Because
  53. ;;; none of the macros defined by this file are used in functions defined by
  54. ;;; this file the implementation-specific files can just contain the parts of
  55. ;;; this file they want to change.  They don't have to copy this whole file
  56. ;;; and then change the parts they want.
  57. ;;;
  58. ;;; If you make changes or improvements to these files, or if you need some
  59. ;;; low-level part of PCL re-modularized to make it more portable to your
  60. ;;; system please send mail to CommonLoops.pa@Xerox.com.
  61. ;;;
  62. ;;; Thanks.
  63. ;;; 
  64.  
  65. (in-package 'pcl)
  66.  
  67. (eval-when (compile load eval)
  68. (defconstant *optimize-speed*
  69.   #+kcl
  70.   '(optimize)
  71.   #-kcl
  72.   '(optimize (speed 3) (safety 0) (compilation-speed 0) (space 0))
  73.   "List of declarations for locally-optimized internal code.")
  74. )
  75.  
  76.  
  77. ;;; PCL optimizes slot-value accesses on specialized parameters by caching
  78. ;;; methods for each set of classes the method is called on.
  79. ;;; *compile-slot-access-method-functions-at-runtime-p* controls whether
  80. ;;; July 92 stores the method lambda for such methods and compiles them
  81. ;;; at runtime if one of the slot accesses is on a non-:instance allocated
  82. ;;; slot, is on a non-standard instance, or has a user-defined
  83. ;;; slot-value-using-class method.
  84. ;;;   Doing so speeds up slot-accesses because each slot access is directly
  85. ;;; coded in the cached method to be compiled, at the cost of extra compilation
  86. ;;; at runtime.  store-optimized-method-lambda-p can also be specialized
  87. ;;; for the specific kind of generic-function and methods (see methods.lisp).
  88. ;;;   The default is normally T, but can be changed.
  89.  
  90. (declaim (type boolean *compile-slot-access-method-functions-at-runtime-p*))
  91. (defvar *compile-slot-access-method-functions-at-runtime-p* T
  92.   "When T tells PCL to store the lambda source for methods containing slot
  93.    accesses and to compile those slot accesses at runtime in certain cases.")
  94.  
  95. ;;; 
  96. ;;;    For optimization purposes, July 92 PCL adds the variable
  97. ;;; *compile-all-method-functions-p*, that lets a programmer tell PCL
  98. ;;; to make sure that all method functions are compiled, and to trust that
  99. ;;; they will be compiled.  The default is NIL, leaving them compiled or
  100. ;;; uncompiled as normal, so people can debug their programs more easily 
  101. ;;; when loading uncompiled source code.
  102. ;;;   It can be set to T by a program that uses PCL, but *must* be set
  103. ;;; to T before any user methods are loaded (otherwise their method
  104. ;;; functions might have been loaded as uncompiled functions, potentially
  105. ;;; causing nasty things to happen when the method dispatch functions later
  106. ;;; assume that they're compiled).  It is safe for a user program to set
  107. ;;; it to T after PCL itself is loaded, however, because presumably PCL
  108. ;;; will have been loaded as compiled.
  109.  
  110. (declaim (type boolean *compile-all-method-functions-p*))
  111. (defvar *compile-all-method-functions-p* NIL
  112.   "When T tells PCL to compile all cached method-functions and
  113.    to assume that they are compiled.")
  114.  
  115.  
  116. ;;;    *compile-all-slot-initfunctions-p* tells whether all slot
  117. ;;; definition initfunctions should be compiled.  Default is T.
  118. ;;;   It can be set to T or NIL by a program that uses PCL, but should
  119. ;;; *not* ever later be changed to NIL if PCL has been compiled with it
  120. ;;; as T, since the initfunction-funcall's for PCL will have assumed that
  121. ;;; they are all compiled.  Later changing it to T after PCL has been
  122. ;;; compiled with NIL if you change it here, however, is safe.
  123.  
  124. (declaim (type boolean *compile-all-slot-initfunctions-p*))
  125. (defvar *compile-all-slot-initfunctions-p* T
  126.   "When T tells PCL to compile all slot initfunctions and assume they are compiled.")
  127.  
  128. (declaim (type boolean *uncompiled-slot-initfunctions-exists-p*))
  129. (defvar *uncompiled-slot-initfunctions-exist-p* NIL
  130.   "Tells whether there have ever been any uncompiled slot initfunctions.")
  131.  
  132.  
  133. ;;;   To adhere to the AMOP while retaining maximum efficiency, method
  134. ;;; functions are actually stored in two ways: as a (1) METHOD-FUNCTION and
  135. ;;; (2) as a METHOD-OPTIMIZED-FUNCTION or METHOD-CLOSURE-GENERATOR.
  136. ;;; METHOD-FUNCTION is the documented function of the AMOP.
  137. ;;; METHOD-OPTIMIZED-FUNCTION is the optimized function used by PCL in actual
  138. ;;; method function invocation (METHOD-FUNCTION-FOR-CACHING). Its arguments are
  139. ;;; the actual arguments of method, and it recieves its next-methods by
  140. ;;; looking at the global *NEXT-METHODS*.  Alternatively, if the method's
  141. ;;; body contains slot-value accesses that can be optimized for caching,
  142. ;;; a METHOD-CLOSURE-GENERATOR is stored instead of METHOD-OPTIMIZED-FUNCTION
  143. ;;; to generate an optimized caching function for given parameter types.
  144. ;;;
  145. ;;; To save space and compile time, generic function STORE-METHOD-FUNCTION-P
  146. ;;; (generic-function method initargs) can be specialized to return NIL
  147. ;;; if the (normally unused) documented method-functions are not needed.
  148. ;;; Default returns T.  Variable *standard-store-method-function-p*, which
  149. ;;; is what the default store-method-function-p method looks up, can be
  150. ;;; set to NIL if it is known that documented method functions will never
  151. ;;; be needed.
  152.  
  153. (declaim (type boolean *standard-store-method-function-p*))
  154. (defvar *standard-store-method-function-p* T
  155.   "Value used by default STORE-METHOD-METHOD-FUNCTION-P method to tell
  156.    whether standard-methods used in standard-generic-functions store
  157.    documented method-functions.")
  158.  
  159.  
  160. ;;;   Global variables keeping track of whether it is safe to use the
  161. ;;; fast slot-value optimizations that directly lookup slot location
  162. ;;; from wrapper (wrapper-optimized-slot-value) or not.  PCL changes
  163. ;;; the appropriate variable to NIL if the user defines any
  164. ;;; slot-value-using-class, (setf slot-value-using-class), or
  165. ;;; slot-boundp-using-class that it doesn't know about (i.e. whose
  166. ;;; specializers aren't found on the corresponding
  167. ;;; *safe-slot-value-using-class-specializers* variable.
  168. ;;;   
  169. ;;;   Compiled slot-value accesses that are not specialized parameters
  170. ;;; inside are generally converted by DEFINE-COMPILER-MACRO to a call
  171. ;;; to macro FAST-SLOT-VALUE.  FAST-SLOT-VALUE checks whether it
  172. ;;; is safe to use the wrapper optimizations by checking the appropriate
  173. ;;; global (e.g. *safe-to-use-slot-value-wrapper-optimizations-p*).
  174. ;;; If it is safe, then WRAPPER-OPTIMIZED-SLOT-VALUE is used to
  175. ;;; access the slot directly by looking it up in the wrapper.  If it
  176. ;;; is not safe, then ACCESSOR-SLOT-VALUE is called to access the
  177. ;;; slot through a reader method defined just for that purpose (March 92 PCL).
  178. ;;;
  179. ;;;   Three optimization hints if defining such slot-value-using-class
  180. ;;; method(s):  (1) If the slot-value-using-class method(s) is a
  181. ;;; "simple" definition that can be looked up in the standard form
  182. ;;; (i.e. only has instance slots stored in the std/fsc/user-instance-slots
  183. ;;; vector, etc.), and therefore is still eligible for the slot-value
  184. ;;; wrapper optimizations, then one can push the method's list of
  185. ;;; specializers method onto the appropriate *safe-slot-value-using-
  186. ;;; class-specializers* global to inform PCL that the method is still
  187. ;;; "safe" (must be done _before_ defining the method).  See file
  188. ;;; user-instances.lisp for an example.
  189. ;;;   (2) If you know you are going to define such unsafe s-v-u-c
  190. ;;; methods, you can change each of the *safe-to-use-slot-value-
  191. ;;; wrapper-optimizations-p* globals defined below to NIL, so that
  192. ;;; PCL doesn't generate any of the WRAPPER-OPTIMIZED-SLOT-VALUE
  193. ;;; code that it won't be able to use anyway.
  194. ;;;   (3) If it is guaranteed that you will *not* define such unsafe
  195. ;;; s-v-u-c methods, then *always-safe-to-use-slot-wrapper-optimizations-p*
  196. ;;; can be set to T, after which slot-value accesses will be compiled
  197. ;;; to assume that slot accesses will always be safe.  This will slightly
  198. ;;; optimize slot-value speed and space because it won't have to
  199. ;;; check *safe-to-use-slot-value-wrapper-optimizations-p* and it
  200. ;;; won't generate the extra code for ACCESSOR-SLOT-VALUE.  If an unsafe
  201. ;;; user-defined s-v-u-c methods id defined after this is set to T,
  202. ;;; however, then all bets are off.
  203. ;;;
  204. ;;;   Do *not* change the three *safe-to-use-slot-value-wrapper-optimizations-p*
  205. ;;; globals by hand (aside for changing their initial values below).
  206.  
  207. (declaim (type boolean *safe-to-use-slot-value-wrapper-optimizations-p*
  208.                        *safe-to-use-set-slot-value-wrapper-optimizations-p*
  209.                        *safe-to-use-slot-boundp-wrapper-optimizations-p*
  210.                        *safe-to-use-slot-wrapper-optimizations-p*))
  211.  
  212. (defvar *safe-to-use-slot-value-wrapper-optimizations-p* T
  213.   "Tells whether it is safe for slot-value to directly access the
  214.    slot through the wrapper for instances of standard-class or
  215.    funcallable-standard-class.  NIL if any non-standard
  216.    slot-value-using-class methods have been defined.")
  217.  
  218. (defvar *safe-to-use-set-slot-value-wrapper-optimizations-p* T
  219.   "Tells whether it is safe for set-slot-value to directly access the
  220.    slot through the wrapper for instances of standard-class or
  221.    funcallable-standard-class.  NIL if any non-standard
  222.    (setf slot-value-using-class) methods have been defined.")
  223.  
  224. (defvar *safe-to-use-slot-boundp-wrapper-optimizations-p* T
  225.   "Tells whether it is safe for slot-boundp to directly access the
  226.    slot through the wrapper for instances of standard-class or
  227.    funcallable-standard-class.  NIL if any non-standard
  228.    slot-boundp-using-class methods have been defined.")
  229.  
  230. (defvar *safe-to-use-slot-wrapper-optimizations-p*
  231.         (and *safe-to-use-slot-value-wrapper-optimizations-p*
  232.              *safe-to-use-set-slot-value-wrapper-optimizations-p*
  233.              *safe-to-use-slot-boundp-wrapper-optimizations-p*)
  234.   "(and *safe-to-use-slot-value-wrapper-optimizations-p*
  235.         *safe-to-use-set-slot-value-wrapper-optimizations-p*
  236.         *safe-to-use-slot-boundp-wrapper-optimizations-p*)")
  237.  
  238.  
  239. (defvar *safe-slot-value-using-class-specializers*
  240.     '((std-class standard-object standard-effective-slot-definition)
  241.       (structure-class structure-object structure-effective-slot-definition))
  242.   "List of the names of the standard slot-value-using-class
  243.    method specializers that it is safe to use the slot-value
  244.    wrapper optimizations for.")
  245.  
  246. (defvar *safe-set-slot-value-using-class-specializers*
  247.   '((T std-class standard-object standard-effective-slot-definition)
  248.     (T structure-class structure-object structure-effective-slot-definition))
  249.   "List of the names of the standard (setf slot-value-using-class)
  250.    method specializers that it is safe to use the slot-value
  251.    wrapper optimizations for.")
  252.  
  253. (defvar *safe-slot-boundp-using-class-specializers*
  254.    '((std-class standard-object standard-effective-slot-definition)
  255.      (structure-class structure-object structure-effective-slot-definition))
  256.   "List of the names of the standard slot-boundp-using-class
  257.    method specializers that it is safe to use the slot-boundp
  258.    wrapper optimizations for.")
  259.  
  260.  
  261. (declaim (type boolean *always-safe-to-use-slot-wrapper-optimizations-p*))
  262. (defvar *always-safe-to-use-slot-wrapper-optimizations-p* NIL
  263.   "Global that programmer can set to T for slight optimizations if it is
  264.    known that it will always be safe to use wrapper-optimized-slot-value
  265.    etc. for slot accesses.  (I.e. there will never be user-defined
  266.    slot-value-using-class methods not in *safe-slot-value-using-class-specializers*.)")
  267.  
  268.  
  269. ;;;   When compiled with the feature :pcl-user-instances, PCL includes the
  270. ;;; hooks built in to allow programmers to define their own USER-INSTANCE
  271. ;;; low-level type of instances different from STD-INSTANCE, FSC-INSTANCE,
  272. ;;; STRUCTURE-INSTANCE, or BUILT-IN-INSTANCE (see file vector.lisp for more
  273. ;;; description, and user-instances.lisp as an example of their use to save
  274. ;;; space over standard instances).
  275. ;;;   Note: pcl-user-instances do not currently work in excl (Allegro) on
  276. ;;; the Sun 4 because of the low-level Sparc lap optimizations in
  277. ;;; quadlap.lisp. :pcl-user-instances is therefore not usually compiled as
  278. ;;; a feature in excl on the sun4.  If you want to use pcl-user-instances
  279. ;;; in excl on the sun4, then the lines defining cpatch and quadlap as
  280. ;;; part of the (defsystem pcl ...) in defsys.lisp must be commented out
  281. ;;; and the below lines modified.
  282.  
  283. ;#-(and excl sun4)
  284. (pushnew :pcl-user-instances *features*)
  285.  
  286.  
  287.  
  288. (defmacro %svref (vector index)
  289.   `(locally (declare #.*optimize-speed*
  290.                      (inline svref))
  291.             (svref (the simple-vector ,vector) (the index ,index))))
  292.  
  293. (defsetf %svref (vector index) (new-value)
  294.   `(locally (declare #.*optimize-speed*
  295.                      (inline svref))
  296.      (setf (svref (the simple-vector ,vector) (the index ,index))
  297.            ,new-value)))
  298.  
  299.  
  300. (defun method-function-storage-form (function)
  301.   "Converts a function to the form it will be stored as a method-function
  302.    or method-function.  This is equal to itself, except that if it is
  303.    uncompiled and *compile-all-method-functions-p* is T, then it
  304.    will be compiled and that value returned."
  305.   (when function
  306.       (if (compiled-function-p function)
  307.           function
  308.           (if *compile-all-method-functions-p*
  309.               (compile-function function)
  310.               function))))
  311.  
  312. (defmacro method-function-funcall (f &rest args)
  313.   (if *compile-all-method-functions-p*
  314.       `(funcall-compiled ,f ,@args)
  315.       `(funcall-function ,f ,@args)))
  316.  
  317. (defmacro method-function-apply (f &rest args)
  318.   (if *compile-all-method-functions-p*
  319.       `(apply-compiled ,f ,@args)
  320.       `(apply-function ,f ,@args)))
  321.  
  322.  
  323. (defun slot-initfunction-storage-form (initfunction)
  324.   "Converts a slot-definition initfunction to the form it will be
  325.    stored as.  This is equal to itself, except that if it is uncompiled
  326.    and *compile-all-slot-initfunctions-p* is T, then it will be compiled
  327.    and that value returned."
  328.   (if initfunction
  329.       (if (compiled-function-p initfunction)
  330.           initfunction
  331.           (if *compile-all-slot-initfunctions-p*
  332.               (compile-initfunction initfunction)
  333.               (progn
  334.                 (setf *uncompiled-slot-initfunctions-exist-p* T)
  335.                 initfunction)))
  336.       (error "No initfunction supplied.")))
  337.  
  338. (defun compile-initfunction (initfunction)
  339.   ;; This is meant to compile the initfunction if it is not compiled yet,
  340.   ;; which should be straightforward, since it will be in the form
  341.   ;; (function (lambda () ,initform)).  This definitely works in lucid,
  342.   ;; excl, and cmu-lisp. ;However, akcl does something strange to that
  343.   ;; form (i.e. convert it to '(lambda-closure () () () () ,initform)),
  344.   ;; which I've patched, but who knows what the heck other lisps do?  -- TL
  345.   (if (compiled-function-p initfunction)
  346.       initfunction
  347.       (compile-function initfunction)))
  348.  
  349. (defmacro slot-initfunction-funcall (f &rest args)
  350.   (if (and *compile-all-slot-initfunctions-p*
  351.            (not *uncompiled-slot-initfunctions-exist-p*))
  352.       `(funcall-compiled ,f ,@args)
  353.       `(funcall-function ,f ,@args)))
  354.  
  355.  
  356. ;;;
  357. ;;; without-interrupts
  358. ;;; 
  359. ;;; OK, Common Lisp doesn't have this and for good reason.  But For all of
  360. ;;; the Common Lisp's that PCL runs on today, there is a meaningful way to
  361. ;;; implement this.  WHAT I MEAN IS:
  362. ;;;
  363. ;;; I want the body to be evaluated in such a way that no other code that is
  364. ;;; running PCL can be run during that evaluation.  I agree that the body
  365. ;;; won't take *long* to evaluate.  That is to say that I will only use
  366. ;;; without interrupts around relatively small computations.
  367. ;;;
  368. ;;; INTERRUPTS-ON should turn interrupts back on if they were on.
  369. ;;; INTERRUPTS-OFF should turn interrupts back off.
  370. ;;; These are only valid inside the body of WITHOUT-INTERRUPTS.
  371. ;;;
  372. ;;; OK?
  373. ;;;
  374. (defmacro without-interrupts (&body body)
  375.   `(macrolet ((interrupts-on () ())
  376.               (interrupts-off () ()))
  377.      (progn ,.body)))
  378.  
  379. (defmacro without-interrupts-simple (&body body)
  380.   `(without-interrupts ,.body))
  381.  
  382.  
  383. ;;; We have to redefine lisp's DEFSTRUCT macro so that pcl knows about
  384. ;;; all the structure-classes.
  385.  
  386. (defmacro pcl-defstruct (name-and-options &body slot-descriptions)
  387.   ;; Excludes structures types created with the :type option
  388.   (if (and (listp name-and-options)
  389.            (find-if #'(lambda (option)
  390.                         (and (consp option) (eq (car option) ':type)))
  391.                     (cdr name-and-options)))
  392.       `(original-defstruct ,name-and-options ,@slot-descriptions)
  393.       (let ((name-and-options
  394.               (if (listp name-and-options)
  395.                   name-and-options
  396.                   (list name-and-options))))
  397.         (unless (or (eq (car name-and-options) 'structure-object)
  398.                     (find-if #'(lambda (option)
  399.                                  (and (consp option)
  400.                                       (eq (car option) ':include)))
  401.                              (cdr name-and-options)))
  402.           (setf name-and-options
  403.                 (append name-and-options '((:include structure-object)))))
  404.         `(progn
  405.            (store-defstruct-form '(,name-and-options ,@slot-descriptions))
  406.            (original-defstruct ,name-and-options ,@slot-descriptions)))))
  407.  
  408. (redefine-macro 'defstruct 'pcl-defstruct)
  409. (setf (macro-function 'original-defstruct) (original-definition 'defstruct))
  410.  
  411.  
  412. (defvar *structure-table* (make-hash-table :test 'eq))
  413.  
  414. (defun store-defstruct-form (defstruct-source)
  415.   (setf (gethash (caar defstruct-source) *structure-table*)
  416.         defstruct-source))
  417.  
  418. (defun defstruct-form (structure-name)
  419.   (gethash structure-name *structure-table*))
  420.  
  421. (defun defstruct-form-class-name (defstruct-form)
  422.   ;; Returns the name of the structure defined by the defstruct-form.
  423.   (caar defstruct-form))
  424.  
  425. (defun defstruct-form-conc-name (defstruct-form)
  426.   ;; Returns a string of the conc-name given by the defstruct source.
  427.   (let ((conc-name-option (assq :conc-name (cdar defstruct-form))))
  428.     (if conc-name-option
  429.         (if (cadr conc-name-option)
  430.             (symbol-name (cadr conc-name-option))
  431.             "")
  432.         (concatenate 'simple-string
  433.                      (symbol-name (defstruct-form-class-name defstruct-form))
  434.                      "-"))))
  435.  
  436. (defun defstruct-form-predicate-name (defstruct-form)
  437.   ;; Returns a string of the predicate-name given by the defstruct source.
  438.   (let ((predicate-option (assq :predicate (cdar defstruct-form))))
  439.     (if predicate-option
  440.         (cadr predicate-option)
  441.         (let ((class-name (defstruct-form-class-name defstruct-form)))
  442.           (intern (concatenate 'simple-string (symbol-name class-name) "-P")
  443.                   (symbol-package class-name))))))
  444.  
  445. (defun defstruct-form-constructor (defstruct-form)
  446.   (let ((constructor-option (assq :constructor (cdar defstruct-form))))
  447.     (if constructor-option
  448.         (cdr constructor-option)
  449.         (let ((class-name (defstruct-form-class-name defstruct-form)))
  450.         (list
  451.           (intern (concatenate 'simple-string "MAKE-" (symbol-name class-name))
  452.                   (symbol-package class-name))
  453.           ())))))
  454.  
  455. #-(or cmu excl ibcl kcl lucid)
  456. (defmacro structurep (x)
  457.   `(typep ,x 'structure))
  458.  
  459. #-(or cmu excl ibcl kcl lucid)
  460. (defmacro structure-type (x)
  461.   `(type-of ,x))
  462.  
  463. #-(or cmu kcl lucid)
  464. (defun known-structure-type-p (symbol)
  465.   (not (null (gethash symbol *structure-table*))))
  466.  
  467. (defmacro structure-instance-p (x)
  468.   "All structures except std-instance structures match."
  469.   (once-only (x)
  470.     `(locally
  471.        (declare #.*optimize-speed*)
  472.        (and (structurep ,x)
  473.             (not (eq (structure-type ,x) 'std-instance))))))
  474.  
  475. (defun structure-type-included-type-name (symbol)
  476.   (let ((defstruct-source (gethash symbol *structure-table*)))
  477.     (cadr (assq :include (cdar defstruct-source)))))
  478.  
  479.  
  480. ;;;
  481. ;;;  Very Low-Level representation of instances with meta-class standard-class.
  482. ;;;
  483. (defstruct (std-instance (:predicate std-instance-p)
  484.                          (:conc-name %std-instance-)
  485.                          (:constructor %%allocate-instance--class ())
  486.                          (:print-function print-std-instance))
  487.   (wrapper nil)
  488.   (slots nil))
  489.  
  490. (defmacro std-instance-wrapper (x) `(%std-instance-wrapper ,x))
  491. (defmacro std-instance-slots   (x) `(%std-instance-slots ,x))
  492.  
  493. (defun print-std-instance (instance stream depth) ;A temporary definition used
  494.   (declare (ignore depth))                        ;for debugging the bootstrap
  495.   (printing-random-thing (instance stream)        ;code of PCL (See high.lisp).
  496.     (let ((class (class-of instance)))
  497.       (if (or (eq class (find-class 'standard-class nil))
  498.               (eq class (find-class 'funcallable-standard-class nil))
  499.               (eq class (find-class 'built-in-class nil)))
  500.           (format stream "~a ~a" (early-class-name class)
  501.                   (early-class-name instance))
  502.           (format stream "~a" (early-class-name class))))))
  503.  
  504. (defmacro %allocate-instance--class (static-slot-storage-copy)
  505.   `(let ((instance (%%allocate-instance--class)))
  506.      (%allocate-instance--class-1 ,static-slot-storage-copy instance)
  507.      instance))
  508.  
  509. (defmacro %allocate-instance--class-1 (static-slot-storage-copy instance)
  510.   (once-only (instance)
  511.     `(progn 
  512.        (setf (std-instance-slots ,instance)
  513.              (%allocate-static-slot-storage--class ,static-slot-storage-copy)))))
  514.  
  515. ;;;
  516. ;;; This is the value that we stick into a slot to tell us that it is unbound.
  517. ;;; It may seem gross, but for performance reasons, we make this an interned
  518. ;;; symbol.  That means that the fast check to see if a slot is unbound is to
  519. ;;; say (EQ <val> '..SLOT-UNBOUND..).  That is considerably faster than looking
  520. ;;; at the value of a special variable.  Be careful, there are places in the
  521. ;;; code which actually use ..slot-unbound.. rather than this variable.  So
  522. ;;; much for modularity
  523. ;;; 
  524. (defconstant *slot-unbound* '..slot-unbound..)
  525.  
  526. ;;; As of July 92 PCL, %allocate-static-slot-storage--class does not take
  527. ;;; a number of slots.  As per the optimization suggestion in the first two
  528. ;;; chapters of the CLOS specification, it instead takes a copy of the slot
  529. ;;; storage vector and copies it.  This original vector copy (stored in
  530. ;;; wrapper-allocate-static-slot-storage-copy in the wrappers)  holds the
  531. ;;; results of the slot :initform forms that neither produce or depend on
  532. ;;; side-effects (with any other slots holding *slot-unbound*).
  533.  
  534. (defmacro %allocate-static-slot-storage--class (static-slot-storage-copy)
  535.   `(locally (declare #.*optimize-speed*)
  536.      (copy-simple-vector ,static-slot-storage-copy)))
  537.  
  538. (defmacro %allocate-origional-static-slot-storage-copy (no-of-slots)
  539.   `(make-array ,no-of-slots :initial-element *slot-unbound*))
  540.  
  541. (defmacro std-instance-class (instance)
  542.   `(wrapper-class (std-instance-wrapper ,instance)))
  543.  
  544.  
  545.  
  546.   ;;   
  547. ;;;;;; FUNCTION-ARGLIST
  548.   ;;
  549. ;;; Given something which is functionp, function-arglist should return the
  550. ;;; argument list for it.  PCL does not count on having this available, but
  551. ;;; MAKE-SPECIALIZABLE works much better if it is available.  Versions of
  552. ;;; function-arglist for each specific port of pcl should be put in the
  553. ;;; appropriate xxx-low file. This is what it should look like:
  554. ;(defun function-arglist (function)
  555. ;  (<system-dependent-arglist-function> function))
  556.  
  557. (defun function-pretty-arglist (function)
  558.   (declare (ignore function))
  559.   ())
  560.  
  561. (defsetf function-pretty-arglist set-function-pretty-arglist)
  562.  
  563. (defun set-function-pretty-arglist (function new-value)
  564.   (declare (ignore function))
  565.   new-value)
  566.  
  567. ;;;
  568. ;;; set-function-name
  569. ;;; When given a function should give this function the name <new-name>.
  570. ;;; Note that <new-name> is sometimes a list.  Some lisps get the upset
  571. ;;; in the tummy when they start thinking about functions which have
  572. ;;; lists as names.  To deal with that there is set-function-name-intern
  573. ;;; which takes a list spec for a function name and turns it into a symbol
  574. ;;; if need be.
  575. ;;;
  576. ;;; When given a funcallable instance, set-function-name MUST side-effect
  577. ;;; that FIN to give it the name.  When given any other kind of function
  578. ;;; set-function-name is allowed to return new function which is the 'same'
  579. ;;; except that it has the name.
  580. ;;;
  581. ;;; In all cases, set-function-name must return the new (or same) function.
  582. ;;; 
  583. (defun set-function-name (function new-name)
  584.   (declare (notinline set-function-name-1 intern-function-name))
  585.   (set-function-name-1 function
  586.                        (intern-function-name new-name)
  587.                        new-name))
  588.  
  589. (defun set-function-name-1 (function new-name uninterned-name)
  590.   (declare (ignore new-name uninterned-name))
  591.   function)
  592.  
  593. (defun intern-function-name (name)
  594.   (cond ((symbolp name) name)
  595.         ((listp name)
  596.          (intern (let ((*package* *the-pcl-package*)
  597.                        (*print-case* :upcase)
  598.                        (*print-pretty* nil)
  599.                        (*print-gensym* 't))
  600.                    (format nil "~S" name))
  601.                  *the-pcl-package*))))
  602.  
  603.  
  604. ;;;
  605. ;;; COMPILE-LAMBDA
  606. ;;;
  607. ;;; This is like the Common Lisp function COMPILE.  In fact, that is what
  608. ;;; it ends up calling.  The difference is that it deals with things like
  609. ;;; watching out for recursive calls to the compiler or not calling the
  610. ;;; compiler in certain cases or allowing the compiler not to be present.
  611. ;;;
  612. ;;; This starts out with several variables and support functions which 
  613. ;;; should be conditionalized for any new port of PCL.  Note that these
  614. ;;; default to reasonable values, many new ports won't need to look at
  615. ;;; these values at all.
  616. ;;;
  617. ;;; *COMPILER-PRESENT-P*        NIL means the compiler is not loaded
  618. ;;;
  619. ;;; *COMPILER-SPEED*            one of :FAST :MEDIUM or :SLOW
  620. ;;;
  621. ;;; *COMPILER-REENTRANT-P*      T   ==> OK to call compiler recursively
  622. ;;;                             NIL ==> not OK
  623. ;;;
  624. ;;; function IN-THE-COMPILER-P  returns T if in the compiler, NIL otherwise
  625. ;;;                             This is not called if *compiler-reentrant-p*
  626. ;;;                             is T, so it only needs to be implemented for
  627. ;;;                             ports which have non-reentrant compilers.
  628. ;;;
  629. ;;;
  630. ;;; TL: 07/92: Added name optional parameter to compile-lambda to
  631. ;;; allow the lambda to be compiled with a given function name.
  632.  
  633. (defvar *compiler-present-p* t)
  634.  
  635. (defvar *compiler-speed*
  636.         #+(or KCL IBCL GCLisp) :slow
  637.         #-(or KCL IBCL GCLisp) :fast)
  638.  
  639. (defvar *compiler-reentrant-p*
  640.         #+(and (not XKCL) (or KCL IBCL)) nil
  641.         #-(and (not XKCL) (or KCL IBCL)) t)
  642.  
  643. (defun in-the-compiler-p ()
  644.   #+(and (not xkcl) (or KCL IBCL)) compiler::*compiler-in-use*
  645.   #+gclisp (typep (eval '(function (lambda ()))) 'lexical-closure)
  646.   )
  647.  
  648. (defun compile-function (function)
  649.   (cond #+kcl
  650.         ((and (listp function) (eq (car function) 'lambda-closure))
  651.          (compile-lambda `(lambda ,@(cddddr function))))
  652.         ((functionp function) (compile-lambda function))
  653.         (T "Function isn't in expected function form -- see
  654.             documentation of PCL::COMPILE-FUNCTION.")))
  655.  
  656. (defun compile-lambda (lambda &optional (desirability :fast) name)
  657.   (cond ((null *compiler-present-p*)
  658.          (compile-lambda-uncompiled lambda name))
  659.         ((and (null *compiler-reentrant-p*)
  660.               (in-the-compiler-p))
  661.          (compile-lambda-deferred lambda name))
  662.         ((eq desirability :fast)
  663.          (compile name lambda))
  664.         ((and (eq desirability :medium)
  665.               (memq *compiler-speed* '(:fast :medium)))
  666.          (compile name lambda))
  667.         ((and (eq desirability :slow)
  668.               (eq *compiler-speed* ':fast))
  669.          (compile name lambda))
  670.         (t
  671.           (compile-lambda-uncompiled lambda name))))
  672.  
  673. (defun compile-lambda-uncompiled (uncompiled &optional name)
  674.   (let* ((function (coerce uncompiled 'function))
  675.          (form #'(lambda (&rest args) (apply function args))))
  676.     (if name
  677.         (progn
  678.           (setf (symbol-function name) form)
  679.           name)
  680.         form)))
  681.  
  682. (defun compile-lambda-deferred (uncompiled &optional name)
  683.   (let* ((function (coerce uncompiled 'function))
  684.          (compiled nil)
  685.          (form
  686.            #'(lambda (&rest args)
  687.               (if compiled
  688.                   (apply (the compiled-function compiled) args)
  689.                   (if (in-the-compiler-p)
  690.                       (apply function args)
  691.                       (progn (setq compiled (compile name uncompiled))
  692.                              (apply (the compiled-function compiled) args)))))))
  693.     (if name
  694.         (progn
  695.           (setf (symbol-function name) form)
  696.           name)
  697.         form)))
  698.  
  699. (defmacro precompile-random-code-segments (&optional system)
  700.   `(progn
  701.      (eval-when (compile) (before-precompile-random-code-segments))
  702.      (precompile-function-generators ,system)
  703.      (precompile-dfun-constructors ,system)))
  704.  
  705. (defmacro force-compile (fn-name)
  706.   "If the function named by FN-NAME isn't compiled, then compile it."
  707.   (once-only (fn-name)
  708.     `(unless (really-compiled-function-p (symbol-function ,fn-name))
  709.        #+(and (not XKCL) (or KCL IBCL))
  710.        (if (in-the-compiler-p)
  711.            (in-compiler-force-compile ,fn-name)
  712.            (compile ,fn-name))
  713.        #-(and (not XKCL) (or KCL IBCL))
  714.        (compile ,fn-name))))
  715.  
  716. (defun in-compiler-force-compile (fn-name)
  717.   (let ((sym-fn (symbol-function fn-name)))
  718.     (if (and (consp sym-fn) (eq (car sym-fn) 'lambda-block))
  719.         (compile-lambda `(lambda ,@(cddr sym-fn)) fn-name)
  720.         (error "Uncompiled SYMBOL-FUNCTION of ~S in unexpected
  721.                 form (FORCE-COMPILE)" fn-name))))
  722.  
  723.  
  724.  
  725. (defun record-definition (type spec &rest args)
  726.   (declare (ignore type spec args))
  727.   ())
  728.  
  729. (defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun)
  730.  
  731.  
  732. ;Low level functions for structures
  733.  
  734.  
  735. ;Functions on arbitrary objects
  736.  
  737.  
  738.